home *** CD-ROM | disk | FTP | other *** search
/ United Public Domain Gold 2 / United Public Domain Gold 2.iso / utilities / pu219.dms / pu219.adf / SOURCES / Bugs.mod next >
Text File  |  1992-07-16  |  7KB  |  261 lines
  1. (**************************************************************************
  2. **                                      **
  3. **         #####  ##   ##  #####   #####      written by:             **
  4. **         ##  ## ##   ## ##      ##         Robert Brandner         **
  5. **         #####  ##   ## ##  ###  ####      Schillerstr. 3         **
  6. **         ##  ## ##   ## ##   ##     ##     A-8280 Fürstenfeld         **
  7. **         #####   #####   #####  #####      AUSTRIA/EUROPE         **
  8. **                                       **
  9. ** This program is written in Modula-II using the compiler M2Amiga V3.3d **
  10. **                                     **                                    **
  11. **************************************************************************)
  12.  
  13. MODULE Bugs;
  14.  
  15. IMPORT Intuition;
  16. FROM Graphics IMPORT
  17.   RastPortPtr,SetAPen,RectFill,ReadPixel,VBeamPos;
  18. FROM SYSTEM IMPORT
  19.   ADDRESS,ADR,INLINE;
  20. FROM Exec IMPORT
  21.   AllocMem,FreeMem,MemReqs,MemReqSet,CopyMem,Byte,
  22.   SetTaskPri,FindTask,TaskPtr;
  23. FROM RandomNumber IMPORT
  24.   RND,PutSeed;
  25. FROM Hardware IMPORT
  26.   ciaa,CiaaPraFlags,CiaaPraFlagSet;
  27.  
  28.  
  29. CONST STARTBUGS=10; (* Anzahl der Bugs am Anfang *)
  30.       DEATH=-20;
  31.       SATIATED=1000;
  32.       ADULT=800;
  33.       NOMOVE=0;
  34.       VERYOLD=ADULT*3;
  35.       ONEBITE=40;
  36.  
  37.       TPRI=0;        (* Taskpriorität *)
  38.  
  39.  
  40. TYPE
  41.   BugPtr=POINTER TO Bug;
  42.   Bug=RECORD
  43.     x,y,richt,alter,energie : INTEGER;
  44.     gen      : ARRAY[0..5] OF INTEGER;
  45.     p        : ARRAY[0..5] OF LONGINT;
  46.     next     : BugPtr;
  47.     (* folgende Zeile dient dazu, das Programm so richtig gemein zu machen *)
  48.     (* speicherfress:ARRAY[0..GEMEIN] OF CHAR *);
  49.   END;
  50.  
  51.  
  52. VAR
  53.   IntBase        : Intuition.IntuitionBasePtr;
  54.   rp             : RastPortPtr;
  55.   buglist,newbug : BugPtr;
  56.   dx,dy          : POINTER TO ARRAY[0..5] OF INTEGER;
  57.   i,xmax,ymax    : INTEGER;
  58.   thisTask       : TaskPtr;
  59.   old         : Byte;
  60.  
  61.  
  62. (* $R- Bereichskontrolle *)
  63. (* $S- Stacküberlauf     *)
  64. (* $V- Über-/Unterlauf   *)
  65.  
  66.  
  67. PROCEDURE AllocBug():BugPtr; (* Speicher für neuen Bug *)
  68.   BEGIN
  69.     RETURN AllocMem(SIZE(Bug),MemReqSet{public,memClear});
  70.   END AllocBug;
  71.  
  72.  
  73. PROCEDURE InitBug(b:BugPtr);
  74.   VAR
  75.     i:INTEGER;
  76.   BEGIN
  77.     WITH b^ DO
  78.       x:=1+3*RND(xmax/3);
  79.       y:=1+3*RND(ymax/3);
  80.       richt:=0;
  81.       alter:=0;
  82.       energie:=40;
  83.       FOR i:=0 TO 5 DO gen[i]:=5 END;
  84.       p[0]:=gen[0];
  85.       FOR i:=1 TO 5 DO p[i]:=p[i-1]+gen[i] END;
  86.       next:=NIL;
  87.     END;
  88.   END InitBug;
  89.  
  90.  
  91. PROCEDURE AppendBug(VAR bl,b:BugPtr);           (* Bug an Bug Liste anfügen *)
  92.   VAR
  93.     help:BugPtr;
  94.   BEGIN
  95.     IF bl=NIL THEN
  96.       bl:=b
  97.     ELSE
  98.       help:=bl;
  99.       WHILE help^.next#NIL DO help:=help^.next END;
  100.       help^.next:=b;
  101.     END;
  102.   END AppendBug;
  103.  
  104.  
  105. PROCEDURE KillBug(VAR prev,bl:BugPtr);
  106.   VAR
  107.     help:BugPtr;
  108.   BEGIN
  109.     help:=bl;
  110.     IF bl=buglist THEN               (* Ersten Bug in Liste löschen      *)
  111.       buglist:=buglist^.next;
  112.       prev:=buglist;
  113.       bl:=buglist;
  114.     ELSE                  (* Bugs in Liste löschen          *)
  115.       bl:=bl^.next;
  116.       prev^.next:=bl;
  117.     END;
  118.     FreeMem(help,SIZE(Bug));          (* Speicher freigeben.              *)
  119.   END KillBug;
  120.  
  121.  
  122. PROCEDURE SplitBug(VAR bl,b:BugPtr);
  123.   VAR
  124.     new:BugPtr;
  125.     zufall,i:INTEGER;
  126.   BEGIN
  127.     new:=AllocBug();
  128.     IF new=NIL THEN RETURN END;       (* kein Speicher mehr           *)
  129.     b^.energie:=b^.energie/2;          (* Vaterenergie halbieren           *)
  130.     b^.alter:=0;
  131.     CopyMem(b,new,SIZE(Bug));              (* Vaterwerte kopieren              *)
  132.     WITH new^ DO
  133.       zufall:=RND(6);              (* Mutierendes Gen bestimmen        *)
  134.       gen[zufall]:=gen[zufall]+1;      (* Mutation                  *)
  135.       p[0]:=gen[0];
  136.       FOR i:=1 TO 5 DO p[i]:=p[i-1]+gen[i] END;
  137.       next:=NIL;
  138.     END;
  139.     AppendBug(bl,new);
  140.     WITH b^ DO
  141.       zufall:=RND(6);              (* Mutierendes Gen bestimmen        *)
  142.       gen[zufall]:=gen[zufall]-1;      (* Mutation                  *)
  143.       IF gen[zufall]<0 THEN gen[zufall]:=0 END;
  144.       p[0]:=gen[0];
  145.       FOR i:=1 TO 5 DO p[i]:=p[i-1]+gen[i] END;
  146.     END;
  147.   END SplitBug;
  148.  
  149.  
  150. PROCEDURE DrawBug(x,y,c:INTEGER);
  151.   BEGIN
  152.     IF (x<xmax) AND (y<ymax) THEN
  153.       SetAPen(rp,c);
  154.       RectFill(rp,x-1,y-1,x+1,y+1);
  155.     END
  156.   END DrawBug;
  157.  
  158.  
  159. PROCEDURE MoveBugs(bl:BugPtr);
  160.   VAR
  161.     nricht,zufall,xo,yo,col:INTEGER;
  162.     ok:BOOLEAN;
  163.     prev:BugPtr;
  164.  
  165.   BEGIN
  166.     prev:=bl;
  167.     WHILE bl#NIL DO
  168.       xo:=bl^.x; yo:=bl^.y;
  169.       IF (bl^.energie<=DEATH) OR          (* verhungert   ..REQUIESCAT..      *)
  170.         (bl^.alter>VERYOLD) THEN          (* zu alt.      ...IN.PACE....      *)
  171.         DrawBug(xo,yo,0);
  172.         KillBug(prev,bl);
  173.       ELSE
  174.         DEC(bl^.energie);
  175.         INC(bl^.alter);
  176.         IF bl^.energie>NOMOVE THEN        (* genug Energie für Bewegung       *)
  177.           WITH bl^ DO
  178.             DEC(energie);
  179.             INC(alter);
  180.             zufall:=RND(p[5]+1);
  181.             nricht:=-1; ok:=FALSE;
  182.             REPEAT
  183.               INC(nricht);
  184.             UNTIL zufall<=p[nricht];
  185.             richt:=(richt+nricht) MOD 6;  (* neue Orientierung                *)
  186.             xo:=x;yo:=y;
  187.             x:=x+dx^[richt];          (* neue Position              *)
  188.             y:=y+dy^[richt];           (* neue Position                    *)
  189.             IF x<1 THEN x:=1 END;
  190.             IF x>xmax THEN x:=xmax END;
  191.             IF y<1 THEN y:=1 END;
  192.             IF y>ymax THEN y:=ymax END;
  193.             col:=ReadPixel(rp,x,y);
  194.             IF ODD(col) THEN
  195.               INC(energie,ONEBITE);
  196.             END;
  197.             DrawBug(xo,yo,0);
  198.             DrawBug(x,y,2);
  199.           END; (* WITH *)
  200.           IF (bl^.alter>=ADULT) AND (bl^.energie>=SATIATED) THEN
  201.             SplitBug(buglist,bl);      (* Fortpflanzung durch Teilung      *)
  202.           END;
  203.         END;                   (* IF energie>NOMOVE               *)
  204.         prev:=bl;               (* Zeiger auf Vorgänger          *)
  205.         bl:=bl^.next;              (* in Liste weitergehen          *)
  206.       END;
  207.     END;
  208.   END MoveBugs;
  209.  
  210.  
  211. PROCEDURE RemoveBugs(VAR bl:BugPtr);      (* Speicher wieder freigeben        *)
  212.   VAR
  213.     help:BugPtr;
  214.   BEGIN
  215.     WHILE bl#NIL DO
  216.       help:=bl^.next;
  217.       FreeMem(bl,SIZE(Bug));
  218.       bl:=help;
  219.     END;
  220.   END RemoveBugs;
  221.  
  222.  
  223. PROCEDURE dxData; (* $E- *)
  224.   BEGIN
  225.     INLINE(0,2,2,0,-2,-2);
  226.   END dxData;
  227.  
  228.  
  229. PROCEDURE dyData; (* $E- *)
  230.   BEGIN
  231.     INLINE(2,1,-1,-2,-1,1);
  232.   END dyData;
  233.  
  234.  
  235. BEGIN (* Bugs *)
  236.   thisTask:=FindTask(NIL);
  237.   old:=SetTaskPri(thisTask,TPRI);      (* Taskpriorität niedrig machen     *)
  238.   PutSeed(VBeamPos());              (* Zufall vom Videostrahl abhängig  *)
  239.   dx:=ADR(dxData);
  240.   dy:=ADR(dyData);
  241.   IntBase:=ADR(Intuition);                (* Adresse der IntuitionBase        *)
  242.   xmax:=IntBase^.activeScreen^.width-4;
  243.   ymax:=IntBase^.firstScreen^.height-4;
  244.   FOR i:=1 TO STARTBUGS DO          (* STARTBUGS Bugs machen           *)
  245.     newbug:=AllocBug();
  246.     IF newbug#NIL THEN
  247.       InitBug(newbug);
  248.       AppendBug(buglist,newbug);
  249.     END;
  250.   END;
  251.   LOOP
  252.     rp:=ADR(IntBase^.activeScreen^.rastPort); (* immer im aktiven Screen!     *)
  253.     xmax:=IntBase^.activeScreen^.width-2;
  254.     ymax:=IntBase^.firstScreen^.height-2;
  255.     MoveBugs(buglist);
  256.     IF (buglist=NIL) OR NOT (gamePort1 IN ciaa.pra) THEN EXIT END;
  257.   END;
  258.   RemoveBugs(buglist);
  259.   Intuition.DisplayBeep(NIL);          (*** Test ***)
  260. END Bugs.
  261.